home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / lib / perl5 / 5.8.7 / ExtUtils / Constant / XS.pm < prev   
Text File  |  2006-04-25  |  6KB  |  253 lines
  1. package ExtUtils::Constant::XS;
  2.  
  3. use strict;
  4. use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56);
  5. use Carp;
  6. use ExtUtils::Constant::Utils 'perl_stringify';
  7. require ExtUtils::Constant::Base;
  8.  
  9.  
  10. @ISA = qw(ExtUtils::Constant::Base Exporter);
  11. @EXPORT_OK = qw(%XS_Constant %XS_TypeSet);
  12.  
  13. $VERSION = '0.01';
  14.  
  15. $is_perl56 = ($] < 5.007 && $] > 5.005_50);
  16.  
  17. =head1 NAME
  18.  
  19. ExtUtils::Constant::Base - base class for ExtUtils::Constant objects
  20.  
  21. =head1 SYNOPSIS
  22.  
  23.     require ExtUtils::Constant::XS;
  24.  
  25. =head1 DESCRIPTION
  26.  
  27. ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C
  28. code for XS modules' constants.
  29.  
  30. =head1 BUGS
  31.  
  32. Nothing is documented.
  33.  
  34. Probably others.
  35.  
  36. =head1 AUTHOR
  37.  
  38. Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
  39. others
  40.  
  41. =cut
  42.  
  43. # '' is used as a flag to indicate non-ascii macro names, and hence the need
  44. # to pass in the utf8 on/off flag.
  45. %XS_Constant = (
  46.         ''    => '',
  47.         IV    => 'PUSHi(iv)',
  48.         UV    => 'PUSHu((UV)iv)',
  49.         NV    => 'PUSHn(nv)',
  50.         PV    => 'PUSHp(pv, strlen(pv))',
  51.         PVN   => 'PUSHp(pv, iv)',
  52.         SV    => 'PUSHs(sv)',
  53.         YES   => 'PUSHs(&PL_sv_yes)',
  54.         NO    => 'PUSHs(&PL_sv_no)',
  55.         UNDEF => '',    # implicit undef
  56. );
  57.  
  58. %XS_TypeSet = (
  59.         IV    => '*iv_return = ',
  60.         UV    => '*iv_return = (IV)',
  61.         NV    => '*nv_return = ',
  62.         PV    => '*pv_return = ',
  63.         PVN   => ['*pv_return = ', '*iv_return = (IV)'],
  64.         SV    => '*sv_return = ',
  65.         YES   => undef,
  66.         NO    => undef,
  67.         UNDEF => undef,
  68. );
  69.  
  70. sub header {
  71.   my $start = 1;
  72.   my @lines;
  73.   push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
  74.   push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
  75.   foreach (sort keys %XS_Constant) {
  76.     next if $_ eq '';
  77.     push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
  78.   }
  79.   push @lines, << 'EOT';
  80.  
  81. #ifndef NVTYPE
  82. typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
  83. #endif
  84. #ifndef aTHX_
  85. #define aTHX_ /* 5.6 or later define this for threading support.  */
  86. #endif
  87. #ifndef pTHX_
  88. #define pTHX_ /* 5.6 or later define this for threading support.  */
  89. #endif
  90. EOT
  91.  
  92.   return join '', @lines;
  93. }
  94.  
  95. sub valid_type {
  96.   my ($self, $type) = @_;
  97.   return exists $XS_TypeSet{$type};
  98. }
  99.  
  100. # This might actually be a return statement
  101. sub assignment_clause_for_type {
  102.   my $self = shift;
  103.   my $args = shift;
  104.   my $type = $args->{type};
  105.   my $typeset = $XS_TypeSet{$type};
  106.   if (ref $typeset) {
  107.     die "Type $type is aggregate, but only single value given"
  108.       if @_ == 1;
  109.     return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset;
  110.   } elsif (defined $typeset) {
  111.     confess "Aggregate value given for type $type"
  112.       if @_ > 1;
  113.     return "$typeset$_[0];";
  114.   }
  115.   return ();
  116. }
  117.  
  118. sub return_statement_for_type {
  119.   my ($self, $type) = @_;
  120.   # In the future may pass in an options hash
  121.   $type = $type->{type} if ref $type;
  122.   "return PERL_constant_IS$type;";
  123. }
  124.  
  125. sub return_statement_for_notdef {
  126.   # my ($self) = @_;
  127.   "return PERL_constant_NOTDEF;";
  128. }
  129.  
  130. sub return_statement_for_notfound {
  131.   # my ($self) = @_;
  132.   "return PERL_constant_NOTFOUND;";
  133. }
  134.  
  135. sub default_type {
  136.   'IV';
  137. }
  138.  
  139. sub macro_from_name {
  140.   my ($self, $item) = @_;
  141.   my $macro = $item->{name};
  142.   $macro = $item->{value} unless defined $macro;
  143.   $macro;
  144. }
  145.  
  146. # Keep to the traditional perl source macro
  147. sub memEQ {
  148.   "memEQ";
  149. }
  150.  
  151. sub params {
  152.   my ($self, $what) = @_;
  153.   foreach (sort keys %$what) {
  154.     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
  155.   }
  156.   my $params = {};
  157.   $params->{''} = 1 if $what->{''};
  158.   $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
  159.   $params->{NV} = 1 if $what->{NV};
  160.   $params->{PV} = 1 if $what->{PV} || $what->{PVN};
  161.   $params->{SV} = 1 if $what->{SV};
  162.   return $params;
  163. }
  164.  
  165.  
  166. sub C_constant_prefix_param {
  167.   "aTHX_ ";
  168. }
  169.  
  170. sub C_constant_prefix_param_defintion {
  171.   "pTHX_ ";
  172. }
  173.  
  174. sub namelen_param_definition {
  175.   'STRLEN ' . $_[0] -> namelen_param;
  176. }
  177.  
  178. sub C_constant_other_params_defintion {
  179.   my ($self, $params) = @_;
  180.   my $body = '';
  181.   $body .= ", int utf8" if $params->{''};
  182.   $body .= ", IV *iv_return" if $params->{IV};
  183.   $body .= ", NV *nv_return" if $params->{NV};
  184.   $body .= ", const char **pv_return" if $params->{PV};
  185.   $body .= ", SV **sv_return" if $params->{SV};
  186.   $body;
  187. }
  188.  
  189. sub C_constant_other_params {
  190.   my ($self, $params) = @_;
  191.   my $body = '';
  192.   $body .= ", utf8" if $params->{''};
  193.   $body .= ", iv_return" if $params->{IV};
  194.   $body .= ", nv_return" if $params->{NV};
  195.   $body .= ", pv_return" if $params->{PV};
  196.   $body .= ", sv_return" if $params->{SV};
  197.   $body;
  198. }
  199.  
  200. sub dogfood {
  201.   my ($self, $args, @items) = @_;
  202.   my ($package, $subname, $default_type, $what, $indent, $breakout) =
  203.     @{$args}{qw(package subname default_type what indent breakout)};
  204.   my $result = <<"EOT";
  205.   /* When generated this function returned values for the list of names given
  206.      in this section of perl code.  Rather than manually editing these functions
  207.      to add or remove constants, which would result in this comment and section
  208.      of code becoming inaccurate, we recommend that you edit this section of
  209.      code, and use it to regenerate a new set of constant functions which you
  210.      then use to replace the originals.
  211.  
  212.      Regenerate these constant functions by feeding this entire source file to
  213.      perl -x
  214.  
  215. #!$^X -w
  216. use ExtUtils::Constant qw (constant_types C_constant XS_constant);
  217.  
  218. EOT
  219.   $result .= $self->dump_names ({default_type=>$default_type, what=>$what,
  220.                  indent=>0, declare_types=>1},
  221.                 @items);
  222.   $result .= <<'EOT';
  223.  
  224. print constant_types(); # macro defs
  225. EOT
  226.   $package = perl_stringify($package);
  227.   $result .=
  228.     "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
  229.   # The form of the indent parameter isn't defined. (Yet)
  230.   if (defined $indent) {
  231.     require Data::Dumper;
  232.     $Data::Dumper::Terse=1;
  233.     $Data::Dumper::Terse=1; # Not used once. :-)
  234.     chomp ($indent = Data::Dumper::Dumper ($indent));
  235.     $result .= $indent;
  236.   } else {
  237.     $result .= 'undef';
  238.   }
  239.   $result .= ", $breakout" . ', @names) ) {
  240.     print $_, "\n"; # C constant subs
  241. }
  242. print "#### XS Section:\n";
  243. print XS_constant ("' . $package . '", $types);
  244. __END__
  245.    */
  246.  
  247. ';
  248.  
  249.   $result;
  250. }
  251.  
  252. 1;
  253.